Attribute VB_Name = "modDirectFunctionDelegator"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'   Files:
'     None
'   Minimal VBoost conditionals:
'     None
'   Conditional Compilation Values:
'     DIRECTFUNCTIONDELEGATOR_NOSTACK = 1 'eliminates support for NewDirectDelegator
'     DIRECTFUNCTIONDELEGATOR_NOHEAP = 1  'eliminates support for InitDirectDelegator
'
' This file is discussed in Chapter 11.
'***************************************************************
Option Explicit

#Const STACKALLOCSUPPORT = DIRECTFUNCTIONDELEGATOR_NOSTACK = 0
#Const HEAPALLOCSUPPORT = DIRECTFUNCTIONDELEGATOR_NOHEAP = 0

#If HEAPALLOCSUPPORT Then
'Structure for heap allocated Delegator
Private Type DirectFunctionDelegatorHeapAlloc
    pVTable As Long  'This has to stay at offset 0
    VTable(3) As Long
    cRefs As Long
End Type
#End If 'HEAPALLOCSUPPORT

#If STACKALLOCSUPPORT Then
'Structure for a stack allocated Delegator
Public Type DirectFunctionDelegator
    pVTable As Long  'This has to stay at offset 0
    VTable(3) As Long
End Type
#End If 'STACKALLOCSUPPORT

#If HEAPALLOCSUPPORT Then
'Functions to initialize a Delegator object on an existing DirectFunctionDelegator
Public Function InitDirectDelegator(Delegator As DirectFunctionDelegator, ByVal pfn As Long) As IUnknown
    With Delegator
        .VTable(0) = FuncAddr(AddressOf QueryInterfaceOKQI)
        .VTable(1) = FuncAddr(AddressOf AddRefRelease)
        .VTable(2) = .VTable(1)
        .VTable(3) = pfn
        .pVTable = VarPtr(.VTable(0))
    End With
    CopyMemory InitDirectDelegator, VarPtr(Delegator), 4
End Function
Private Function QueryInterfaceOKQI(This As DirectFunctionDelegator, riid As Long, pvObj As Long) As Long
    pvObj = VarPtr(This)
    This.VTable(0) = FuncAddr(AddressOf QueryInterfaceFail)
End Function
Private Function AddRefRelease(ByVal This As Long) As Long
    'Nothing to do, memory not refcounted
End Function
#End If 'HEAPALLOCSUPPORT

#If HEAPALLOCSUPPORT Then
'Functions to create a refcounted version of the function pointer wrapper object
Public Function NewDirectDelegator(ByVal pfn As Long) As IUnknown
Dim Struct As DirectFunctionDelegatorHeapAlloc
Dim ThisPtr As Long
    With Struct
        ThisPtr = CoTaskMemAlloc(LenB(Struct))
        If ThisPtr = 0 Then Err.Raise 7
        .VTable(0) = FuncAddr(AddressOf QueryInterfaceHeapAllocOKQI)
        .VTable(1) = FuncAddr(AddressOf AddRefHeapAlloc)
        .VTable(2) = FuncAddr(AddressOf ReleaseHeapAlloc)
        .VTable(3) = pfn
        'pVTable must point into the finished buffer, not
        'the temporary structure. Use inline UnsignedAdd
        .pVTable = (ThisPtr Xor &H80000000) + 4 Xor &H80000000
        .cRefs = 1
        CopyMemory ByVal ThisPtr, Struct, LenB(Struct)
        CopyMemory NewDirectDelegator, ThisPtr, 4
    End With
End Function
Private Function QueryInterfaceHeapAllocOKQI(This As DirectFunctionDelegatorHeapAlloc, riid As Long, pvObj As Long) As Long
    With This
        pvObj = VarPtr(.pVTable)
        .cRefs = .cRefs + 1
        .VTable(0) = FuncAddr(AddressOf QueryInterfaceFail)
    End With
End Function
Private Function AddRefHeapAlloc(This As DirectFunctionDelegatorHeapAlloc) As Long
    With This
        .cRefs = .cRefs + 1
        AddRefHeapAlloc = .cRefs
    End With
End Function
Private Function ReleaseHeapAlloc(This As DirectFunctionDelegatorHeapAlloc) As Long
    With This
        .cRefs = .cRefs - 1
        ReleaseHeapAlloc = .cRefs
        If .cRefs = 0 Then
            'Don't try to step over FreeBuffer, we're freeing
            'This, and the debugger could die.
            CoTaskMemFree VarPtr(.pVTable)
        End If
    End With
End Function
#End If 'HEAPALLOCSUPPORT

Private Function QueryInterfaceFail(ByVal This As Long, riid As Long, pvObj As Long) As Long
    pvObj = 0
    QueryInterfaceFail = E_NOINTERFACE
End Function

Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

